CrystalVision Software Se… Wiki Wonder - Wikipedia/CrystalVision Software Services 703: The Wiki Wonder - Wikipedia.iso/0703/Educate/Complete Calc/Setup.exe/lib/tcl/auto.tcl

Text File | 2006-10-25 | 8.3 KB | 385 lines

proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclPkgUnknown tcl::MacOSXPkgUnknown
tcl::MacPkgUnknown} $p] < 0)} {
rename $p {}
}
}
unset -nocomplain auto_execs auto_index auto_oldpath
}


proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global env errorInfo

set dirs {}
set errors {}


if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {



if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}


foreach d $::auto_path {
lappend dirs [file join $d $basename$version]
if {$::tcl_platform(platform) eq "unix"
&& $::tcl_platform(os) eq "Darwin"} {
lappend dirs [file join $d $basename$version Resources Scripts]
}
}

set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]

if {1} {
lappend dirs [file join $grandParentDir library]
lappend dirs [file join $grandParentDir $basename$patch library]
lappend dirs [file join [file dirname $grandParentDir]  $basename$patch library]
}
}
array set seen {}
foreach i $dirs {
if {1 || [interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
if {[info exists seen($norm)]} { continue }
set seen($norm) ""
lappend uniqdirs $i
}
set dirs $uniqdirs
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]


if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
append msg "    $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}



if {[interp issafe]} {
return    ;# Stop sourcing the file here
}


proc auto_mkindex {dir args} {
global errorCode errorInfo

if {[interp issafe]} {
error "can't generate index within safe interpreter"
}

set oldDir [pwd]
cd $dir
set dir [pwd]

append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands.  Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}

auto_mkindex_parser::init
foreach file [eval [linsert $args 0 glob --]] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
set code $errorCode
set info $errorInfo
cd $oldDir
error $msg $info $code
}
}
auto_mkindex_parser::cleanup

set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}


proc auto_mkindex_old {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands.  Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}
foreach file [eval [linsert $args 0 glob --]] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[     ]+([^     ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}


namespace eval auto_mkindex_parser {
variable parser ""          ;# parser used to build index
variable index ""           ;# maintains index as it is built
variable scriptFile ""      ;# name of file being processed
variable contextStack ""    ;# stack of namespace scopes
variable imports ""         ;# keeps track of all imported cmds
variable initCommands ""    ;# list of commands that create aliases

proc init {} {
variable parser
variable initCommands

if {![interp issafe]} {
set parser [interp create -safe]
$parser hide info
$parser hide rename
$parser hide proc
$parser hide namespace
$parser hide eval
$parser hide puts
$parser invokehidden namespace delete ::
$parser invokehidden proc unknown {args} {}


$parser expose namespace
$parser invokehidden rename namespace _%@namespace
$parser expose eval
$parser invokehidden rename eval _%@eval


foreach cmd $initCommands {
eval $cmd
}
}
}
proc cleanup {} {
variable parser
interp delete $parser
unset parser
}
}


proc auto_mkindex_parser::mkindex {file} {
variable parser
variable index
variable scriptFile
variable contextStack
variable imports

set scriptFile $file

set fid [open $file]
set contents [read $fid]
close $fid

set contents [string map "$ \u0000" $contents]

set index ""
set contextStack ""
set imports ""

$parser eval $contents

foreach name $imports {
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}


proc auto_mkindex_parser::hook {cmd} {
variable initCommands

lappend initCommands $cmd
}


proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands


lappend initCommands "\$parser eval [list $cmd]"
}


proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}


proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser

set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {$ns eq ""} {
set fakeName [namespace current]::_%@fake_$tail
} else {
set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
}
proc $fakeName $arglist $body


if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]


set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
$parser alias $alias $fakeName
} else {
$parser alias $name $fakeName
}
return
}


proc auto_mkindex_parser::fullname {name} {
variable contextStack

if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}

if {[namespace qualifiers $name] eq ""} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}

return [string map "\u0000 $" $name]
}



auto_mkindex_parser::command proc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])]  [format { [list source [file join $dir %s]]}  [file split $scriptFile]] "\n"
}


auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser


auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])]  [format { [list source [file join $dir %s]]}  [file split $scriptFile]] "\n"
}
}
}


auto_mkindex_parser::command namespace {op args} {
switch -- $op {
eval {
variable parser
variable contextStack

set name [lindex $args 0]
set args [lrange $args 1 end]

set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {$pattern ne "-force"} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}

return